Celestin Apprentice 4/Apprentice-Release4.iso/Source Code/Libraries/PNL Libraries/MyFMenus.p

Text File | 1995-10-23 | 8.9 KB | 373 lines | [TEXT/CWIE]

unit MyFMenus;

{ From Peter's PNL Libraries }
{ Copyright 1992 Peter N Lewis }
{ This source may be used for any non-commercial purposes as long as I get a mention }
{ in the About box and Docs of any derivative program.  It may not be used in any commercial }
{ application without my permission }

interface

    uses
        Menus, Events, MyCallProc;

    type
        FMenuMenuProc = procedure(themenu,theitem:integer);
        FMenuCommandProc = procedure;

    var
        thefmenu, thefitem: integer;
        menu_modifiers: integer;

    procedure StartupFMenus;
    procedure ConfigureFMenus (default: FMenuMenuProc);

    function GetFMenu (id: integer): MenuHandle;
{ Call this in place of GetMenu, to read in an fmnu resource.  Use InsertMenu to add it to the menu bar }
    procedure SetFCommand (command: OSType; cmdproc: FMenuCommandProc);
{ Call this to associate a procedure with a command OSType }
    procedure SetFSetMenu (command: OSType; smproc: FMenuMenuProc);
{ procedure smproc(themenu,theitem:integer) }
{ Call this to associate a procedure for enabling/disabling the menu item }
    procedure SetFBoth (command: OSType; cmdproc: FMenuCommandProc; smproc: FMenuMenuProc);
{ This is just a short form to set both the command and SetMenu procedures }

    function DoFMenuKey (var er: EventRecord): longInt;
{ Calls SetFMenus and then MDEF_MenuKey }
    procedure SetFMenus;
{ Call this before MenuKey or MenuSelect to set the enables of all the menus }
    procedure SetFMenu (themenu: integer);
{ Call this to set the enables of all the items in themenu }
    procedure DoFMenu (themenu, theitem: integer);
{ Call this to act on a menu selection from either MenuSelect or MenuKey }

{ You probably won't need these }
    procedure AddFCommand (themenu, theitem: integer; command: OSType);
{ Call this to associate a menu item with an OSType - normally done by GetFMenu }
    procedure GetCommand (themenu, theitem: integer; var command: OSType);
{ Call this to figure out what command OSType is associated with a menu item - normally done via DoFMenu }
    procedure DoCommand (themenu, theitem: integer; command: OSType);
{ Call this to execute a menu command - normally done via DoFMenu }

implementation

    uses
        Resources, Script,
        BaseGlobals,MyCallProc, MyMemory, MyStartup;

    const
        min_menu_time = 6;

    type
        fmenuHeader = record
                visible: integer;
                count: integer;
                unknown1: integer;
                menuID: integer;
                unknown2: integer;
                unknown3: integer;
                name: str63;
            end;
        fmenuHeaderPtr = ^fmenuHeader;
        fmenuItem = packed record
                command: OSType;
                mark: char;
                unknown2: byte;
                cmdKey: char;
                disabled: byte;
                name: str63;
            end;
        fmenuItemPtr = ^fmenuItem;
        convertRecord = record
                menu, item: integer;
                cmd: OSType;
                cmdp: FMenuCommandProc;
                smp: FMenuMenuProc;
            end;
        convertArray = array[1..1000] of convertRecord;
        convertPtr = ^convertArray;
        convertHandle = ^convertPtr;

    var
        convert_count: integer;
        converts: convertHandle;
        DefaultMenuProc: FMenuMenuProc;

    procedure AddFCommand (themenu, theitem: integer; command: OSType);
    begin
        if BAND(convert_count, 7) = 0 then begin
            SetHandleSize(handle(converts), (convert_count + 8) * SizeOf(convertRecord));
        end;
        convert_count := convert_count + 1;
        with converts^^[convert_count] do begin
            menu := themenu;
            item := theitem;
            cmd := command;
            cmdp := nil;
            smp := nil;
        end;
    end;

    procedure NextPtr (var p: univ ptr; sp: univ ptr);
    begin
        p := ptr(longInt(sp) + sp^ + 2 - ord(odd(sp^)));
    end;

    function GetFMenu (id: integer): MenuHandle;
        var
            h: handle;
            mh: menuHandle;
            ph: fmenuHeaderPtr;
            p: fmenuItemPtr;
            s: string[70];
            i: integer;
    begin
        h := GetResource('fmnu', id);
        HLock(h);
        ph := fmenuHeaderPtr(h^);
        mh := NewMenu(ph^.menuID, ph^.name);

        NextPtr(p, @ph^.name);
        for i := 1 to ph^.count do begin
            if p^.name = '-' then begin
                AppendMenu(mh, '(-');
            end else begin
                AddFCommand(ph^.menuID, i, p^.command);
                s := p^.name;
                if p^.mark <> chr(0) then begin
                    s := concat(s, '!', p^.mark);
                end;
                if p^.cmdKey <> chr(0) then begin
                    s := concat(s, '/', p^.cmdKey);
                end;
                if p^.disabled = 1 then begin
                    s := concat('(', s);
                end;
                AppendMenu(mh, s);
            end;
            NextPtr(p, @p^.name);
        end;
        ReleaseResource(h);

        GetFMenu := mh;
    end;

    procedure FindMenu (themenu, theitem: integer; var i: integer);
    begin
        i := 1;
        while i <= convert_count do begin
            with converts^^[i] do begin
                if (menu = themenu) and (item = theitem) then begin
                    Exit(FindMenu);
                end;
            end;
            i := i + 1;
        end;
        i := -1;
    end;

    procedure SetFCommand (command: OSType; cmdproc: FMenuCommandProc);
        var
            i: integer;
    begin
        for i := 1 to convert_count do begin
            with converts^^[i] do begin
                if cmd = command then begin
                    cmdp := cmdproc;
                end;
            end;
        end;
    end;

    procedure SetFSetMenu (command: OSType; smproc: FMenuMenuProc);
        var
            i: integer;
    begin
        for i := 1 to convert_count do begin
            with converts^^[i] do begin
                if cmd = command then begin
                    smp := smproc;
                end;
            end;
        end;
    end;

    procedure SetFBoth (command: OSType; cmdproc: FMenuCommandProc; smproc: FMenuMenuProc);
        var
            i: integer;
    begin
        for i := 1 to convert_count do begin
            with converts^^[i] do begin
                if cmd = command then begin
                    cmdp := cmdproc;
                    smp := smproc;
                end;
            end;
        end;
    end;

    procedure GetCommand (themenu, theitem: integer; var command: OSType);
        var
            i: integer;
    begin
        FindMenu(themenu, theitem, i);
        if i = -1 then begin
            command := 'xxx0';
        end else begin
            command := converts^^[i].cmd;
        end;
    end;

    procedure DoCmd (themenu, theitem: integer; cmdp: FMenuCommandProc);
    begin
        thefmenu := themenu;
        thefitem := theitem;
        if cmdp = nil then begin
            DefaultMenuProc(themenu, theitem);
        end else begin
            cmdp;
        end;
    end;

    procedure DoCommand (themenu, theitem: integer; command: OSType);
        var
            cmdproc: FMenuCommandProc;
            i: integer;
    begin
        cmdproc := nil;
        i := 1;
        while i <= convert_count do begin
            with converts^^[i] do begin
                if cmd = command then begin
                    cmdproc := cmdp;
                    leave;
                end;
            end;
            i := i + 1;
        end;
        DoCmd(themenu, theitem, cmdproc);
    end;

    procedure DoFMenu (themenu, theitem: integer);
        var
            i: integer;
            t: longInt;
            tmp_hack: FMenuCommandProc;
    begin
        t := TickCount;
        FindMenu(themenu, theitem, i);
        if i = -1 then begin
            DoCmd(themenu, theitem, nil);
        end else begin
            tmp_hack := converts^^[i].cmdp;
            DoCmd(themenu, theitem, tmp_hack);
        end;
        if not quitNow then begin
            t := TickCount - t;
            if t < min_menu_time then begin
                Delay(min_menu_time - t, t);
            end;
            HiliteMenu(0);
        end;
    end;

    procedure SetFMenus;
        var
            i: integer;
            dummy: boolean;
            er: EventRecord;
    begin
        dummy := OSEventAvail(everyEvent, er);
        menu_modifiers := er.modifiers;
        for i := 1 to convert_count do begin
            with converts^^[i] do begin
                if smp <> nil then begin
                    smp(menu, item);
                end;
            end;
        end;
    end;

    function DoFMenuKey (var er: EventRecord): longInt;
        const
            kMaskVirtualKey = $0000FF00; {get virtual key from event message}
            kMaskASCII1 = $00FF0000;
            kMaskASCII2 = $000000FF; {get key from KeyTrans return}
            kKeyUpMask = $0080;
        var
            h: handle;
            virtualKey, keyCId, state, keyInfo: longInt;
            keycode: integer;
            lowchar, highchar: integer;
            ch: Char;
    begin
        ch := chr(BAND(er.message, $FF));
        if BAND(er.modifiers, optionKey + controlKey) <> 0 then begin
            virtualKey := BSR(BAND(er.message, kMaskVirtualKey), 8);
            keyCode := BOR(BOR(BAND(er.modifiers, BNOT(optionKey + controlKey)), kKeyUpMask), virtualKey);
            state := 0;

            keyCId := GetScriptVariable(GetScriptManagerVariable(smKeyScript), smScriptKeys);
            h := GetResource('KCHR', keyCId);

            if h <> nil then begin
                HLock(h); { KeyTrans won't move memory, but lock it anyway to avoid any purging or foolishness }
                keyInfo := KeyTranslate(h^, keyCode, state);
                ReleaseResource(h);
                LowChar := BAND(keyInfo, $FF);
                HighChar := BAND(BSR(keyInfo, 16), $FF);
                if lowChar <> 0 then begin
                    ch := chr(lowChar);
                end;
                if highChar <> 0 then begin
                    ch := chr(highChar);
                end;
            end;
        end;
        DoFMenuKey := MenuKey(ch);
    end;

    procedure SetFMenu (themenu: integer);
        var
            i: integer;
            dummy: boolean;
            er: EventRecord;
    begin
        dummy := OSEventAvail(everyEvent, er);
        menu_modifiers := er.modifiers;
        for i := 1 to convert_count do begin
            with converts^^[i] do begin
                if (themenu = menu) & (smp <> nil) then begin
                    smp(menu, item);
                end;
            end;
        end;
    end;

    function InitFMenus (var msg: integer): OSStatus;
    begin
        msg := msg; { Unused }
        convert_count := 0;
        InitFMenus := MNewHandle(converts, 0);
    end;

    procedure FinishFMenus;
    begin
        DisposeHandle(handle(converts));
    end;

    procedure ConfigureFMenus (default: FMenuMenuProc);
    begin
        if default = nil then begin
            default := DoFMenu;
        end;
        DefaultMenuProc := default;
    end;

    procedure StartupFMenus;
    begin
        SetStartup(InitFMenus, nil, 0, FinishFMenus);
    end;

end.